Cream of the Crop 25/Cream of the Crop 25.iso/program/fpk65_66.zip/SOURCE/RTL/DOS/DOS.PP

Text File | 1997-02-03 | 22KB | 847 lines

{****************************************************************************

                          FPKPascal Runtime-Library
                          Copyright (c) 1994,97 by
                    Florian Klaempfl and Michael Spiegel

 ****************************************************************************}

{
  History:
  2.7.1994: Version 0.2
            Datenstrukturen sind deklariert sowie
            50 % der Unterprogramme sind implementiert
  12.8.1994: exec implemented
  14.8.1994: findfirst and findnext implemented
  24.8.1994: Version 0.3
  28.2.1995: Version 0.31
             some parameter lists with const optimized
   3.7.1996: bug in fsplit removed (dir and ext were not intializised)
   7.7.1996: packtime and unpacktime implemented
  20.9.1996: Version 0.5
             setftime and getftime implemented
             some optimizations done (integer -> longint)
             procedure fsearch from the LINUX version ported
             msdos call implemented
  26th november 1996:
             better fexpand
  29th january 1997:
             bug in getftime and setftime removed
             setfattr and getfattr added
   2th february 1997: Version 0.9
             bug of searchrec corrected
}

unit dos;

  interface

    uses
       strings;

    const
       { bit masks for CPU flags}
       fcarry = $0001;
       fparity = $0004;
       fauxiliary = $0010;
       fzero = $0040;
       fsign = $0080;
       foverflow  = $0800;

       { Bitmasken fuer Dateiattribute }
       readonly = $01;
       hidden = $02;
       sysfile = $04;
       volumeid = $08;
       directory = $10;
       archive = $20;
       anyfile = $3F;
       fmclosed = $D7B0;
       fminput = $D7B1;
       fmoutput = $D7B2;
       fminout = $D7B3;

    type
       { some string types }
       comstr = string[127];        { Kommandozeilenstring }
       pathstr = string[79];        { String fuer einen Pfadnamen }
       dirstr = string[67];         { String fuer kompletten Pfad }
       namestr = string[8];         { Dateinamenstring }
       extstr = string[4];          { String fuer Dateinamensuffix }

       { search record which is used by findfirst and findnext }
{$PACKRECORDS 1}
       searchrec = record
          fill : array[1..21] of byte;
          attr : byte;
          time : longint;
          reserved : word; { requires the DOS extender (DJ GNU-C) }
          size : longint;
          name : string[15]; { the same size as declared by (DJ GNU C) }
       end;
{$PACKRECORDS 2}

       { file record for untyped files }
       filerec = record
          handle : word;
          mode : word;
          recsize : word;
          _private : array[1..26] of byte;
          userdata: array[1..16] of byte;
          name: array[0..79] of char;
       end;

       { file record for text files }
       textbuf = array[0..127] of char;

       textrec = record
          handle : word;
          mode : word;
          bufSize : word;
          _private : word;
          bufpos : word;
          bufend : word;
          bufptr : ^textbuf;
          openfunc : pointer;
          inoutfunc : pointer;
          flushfunc : pointer;
          closefunc : pointer;
          userdata : array[1..16] of byte;
          name : array[0..79] of char;
          buffer : textbuf;
       end;

       { data structure for the registers needed by msdos and intr }
       registers = record
         case i : integer of
            0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
            1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
            2 : (eax,  ebx,  ecx,  edx,  ebp,  esi,  edi : longint);
       end;

       { record for date and time }
       datetime = record
          year,month,day,hour,min,sec : word;
       end;

    var
       { error variable }
       doserror : integer;

    procedure getdate(var year,month,day,dayofweek : word);
    procedure gettime(var hour,minute,second,sec100 : word);
    function dosversion : word;
    procedure setdate(year,month,day : word);
    procedure settime(hour,minute,second,sec100 : word);
    procedure getcbreak(var breakvalue : boolean);
    procedure setcbreak(breakvalue : boolean);
    procedure getverify(var verify : boolean);
    procedure setverify(verify : boolean);
    function diskfree(drive : byte) : longint;
    function disksize(drive : byte) : longint;
    procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
    procedure findnext(var f : searchRec);

    { is a dummy }
    procedure swapvectors;

{   not supported:
    procedure getintvec(intno : byte;var vector : pointer);
    procedure setintvec(intno : byte;vector : pointer);
    procedure keep(exitcode : word);
}
    procedure msdos(var regs : registers);
    procedure intr(intno : byte;var regs : registers);

    procedure getfattr(var f;var attr : word);
    procedure setfattr(var f;attr : word);

    function fsearch(const path : pathstr;dirlist : string) : pathstr;
    procedure getftime(var f;var time : longint);
    procedure setftime(var f;time : longint);
    procedure packtime (var d: datetime; var time: longint);
    procedure unpacktime (time: longint; var d: datetime);
    function fexpand(const path : pathstr) : pathstr;
    procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
      var ext : extstr);
    procedure exec(const path : pathstr;const comline : comstr);
    function dosexitcode : word;
    function envcount : longint;
    function envstr(index : longint) : string;
    function getenv(const envvar : string): string;

  implementation

    { this was first written for the LINUX version,    }
    { by Michael Van Canneyt but it works also         }
    { for the DOS version (I hope so)                  }
    function fsearch(const path : pathstr;dirlist : string) : pathstr;

      var
         newdir : pathstr;
         p1 : byte;
         s : searchrec;

      begin
         if (pos('?',path)<>0) or (pos('*',path)<>0) then
           { No wildcards allowed in these things }
           fsearch:=''
         else
           begin
              repeat
                { get first path }
                p1:=pos(';',dirlist);
                if p1>0 then
                  begin
                     newdir:=copy(dirlist,1,p1-1);
                     delete(dirlist,1,p1)
                  end
                else
                  begin
                     newdir:=dirlist;
                     dirlist:=''
                  end;
                findfirst(newdir+'\'+path,anyfile,s);
                if doserror=0 then
                  begin
                     newdir:=newdir+'\'+s.name;
                     { this was for LINUX:
                     if pos('.\',newdir)=1 then
                       delete(newdir, 1, 2)
                     { DOS strips off an initial .\ }
                     }
                  end
                else newdir:='';
              until(dirlist='') or (length(newdir)>0);
              fsearch:=newdir;
           end;
      end;

    procedure getftime(var f;var time : longint);

      begin
         asm
            { load handle }
            movl f,%ebx
            movw (%ebx),%bx
            { get date }
            movw $0x5700,%ax
            int $0x21
            shll $16,%edx
            movw %cx,%dx
            movl time,%ebx
            movl %edx,(%ebx)
            xorb %ah,%ah
            movw %ax,U_DOS_DOSERROR
         end;
      end;

   procedure setftime(var f;time : longint);

      begin
         asm
            { load handle }
            movl f,%ebx
            movw (%ebx),%bx
            movl time,%edx
            movl %edx,%ecx
            shrl $16,%edx
            { set date }
            movw $0x5701,%ax
            int $0x21
            xorb %ah,%ah
            movw %ax,U_DOS_DOSERROR
         end;
      end;

    procedure msdos(var regs : registers);

      begin
         intr($21,regs);
      end;

    procedure intr(intno : byte;var regs : registers);

      begin
         asm
            .data
    int86:
            .byte        0xcd
    int86_vec:
            .byte        0x03
            jmp        int86_retjmp

            .text
            movl        8(%ebp),%eax
            movb        %al,int86_vec

            movl        10(%ebp),%eax
            // do not use first int
            addl        $2,%eax

            movl        4(%eax),%ebx
            movl        8(%eax),%ecx
            movl        12(%eax),%edx
            movl        16(%eax),%ebp
            movl        20(%eax),%esi
            movl        24(%eax),%edi
            movl        (%eax),%eax

            jmp        int86
    int86_retjmp:
            pushf
            pushl    %ebp
            pushl       %eax
            movl        %esp,%ebp
            // calc EBP new
            addl        $12,%ebp
            movl        10(%ebp),%eax
            // do not use first int
            addl        $2,%eax

            popl        (%eax)
            movl        %ebx,4(%eax)
            movl        %ecx,8(%eax)
            movl        %edx,12(%eax)
            // restore EBP
            popl    %edx
            movl    %edx,16(%eax)
            movl        %esi,20(%eax)
            movl        %edi,24(%eax)
            // ignore ES and DS
            popl        %ebx        /* flags */
            movl        %ebx,32(%eax)
            // FS and GS too
         end;
      end;

    var
       lastdosexitcode : word;

    procedure exec(const path : pathstr;const comline : comstr);

      procedure do_system(p : pchar);

        begin
           asm
              movl 12(%ebp),%ebx
              movw $0xff07,%ax
              int $0x21
              movw %ax,_LASTDOSEXITCODE
           end;
        end;

      var
         execute : string;
         b : array[0..255] of char;

      begin
         execute:=path+' '+comline;
         move(execute[1],b,length(execute));
         b[length(execute)]:=#0;
         do_system(b);
      end;

    function dosexitcode : word;

      begin
         dosexitcode:=lastdosexitcode;
      end;

    function dosversion : word;

      begin
         asm
            movb $0x30,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            leave
            ret
         end;
      end;

    procedure getdate(var year,month,day,dayofweek : word);

      begin
         asm
            movb $0x2a,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            xorb %ah,%ah
            movl 20(%ebp),%edi
            stosw
            movl 16(%ebp),%edi
            movb %dl,%al
            stosw
            movl 12(%ebp),%edi
            movb %dh,%al
            stosw
            movl 8(%ebp),%edi
            movw %cx,%ax
            stosw
         end;
      end;

    procedure setdate(year,month,day : word);

      begin
         asm
            movw 8(%ebp),%cx
            movb 10(%ebp),%dh
            movb 12(%ebp),%dl
            movb $0x2b,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            xorb %ah,%ah
            movw %ax,U_DOS_DOSERROR
         end;
      end;

    procedure gettime(var hour,minute,second,sec100 : word);

      begin
         asm
            movb $0x2c,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            xorb %ah,%ah
            movl 20(%ebp),%edi
            movb %dl,%al
            stosw
            movl 16(%ebp),%edi
            movb %dh,%al
            stosw
            movl 12(%ebp),%edi
            movb %cl,%al
            stosw
            movl 8(%ebp),%edi
            movb %ch,%al
            stosw
         end;
      end;

    procedure settime(hour,minute,second,sec100 : word);

      begin
         asm
            movb 8(%ebp),%ch
            movb 10(%ebp),%cl
            movb 12(%ebp),%dh
            movb 14(%ebp),%dl
            movb $0x2d,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            xorb %ah,%ah
            movw %ax,U_DOS_DOSERROR
         end;
      end;

    procedure getcbreak(var breakvalue : boolean);

      begin
         asm
            movw $0x3300,%ax
            pushl %ebp
            int $0x21
            popl %ebp
            movl 8(%ebp),%eax
            movb %dl,(%eax)
         end;
      end;

    procedure setcbreak(breakvalue : boolean);

      begin
         asm
            movb 8(%ebp),%dl
            movl $0x3301,%ax
            pushl %ebp
            int $0x21
            popl %ebp
         end;
      end;

    procedure getverify(var verify : boolean);

      begin
         asm
            movb $0x54,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            movl 8(%ebp),%edi
            stosb
         end;
      end;

    procedure setverify(verify : boolean);

      begin
         asm
            movb 8(%ebp),%al
            movl $0x2e,%ah
            pushl %ebp
            int $0x21
            popl %ebp
         end;
      end;

    function diskfree(drive : byte) : longint;

      begin
         asm
            movb 8(%ebp),%dl
            movb $0x36,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            cmpw $-1,%ax
            je LDISKFREE1
            mulw %cx
            mulw %bx
            shll $16,%edx
            movw %ax,%dx
            movl %edx,%eax
            leave
            ret
         LDISKFREE1:
            movl $-1,%eax
            leave
            ret
         end;
      end;

    function disksize(drive : byte) : longint;

      begin
         asm
            movb 8(%ebp),%dl
            movb $0x36,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            movw %dx,%bx
            cmpw $-1,%ax
            je LDISKSIZE1
            mulw %cx
            mulw %bx
            shll $16,%edx
            movw %ax,%dx
            movl %edx,%eax
            leave
            ret
         LDISKSIZE1:
            movl $-1,%eax
            leave
            ret
         end;
      end;

    procedure searchrec2dossearchrec(var f : searchrec);

      var
         l,i : longint;

      begin
         l:=length(f.name);
         for i:=1 to 12 do
           f.name[i-1]:=f.name[i];
         f.name[l]:=#0;
      end;

    procedure dossearchrec2searchrec(var f : searchrec);

      var
         l,i : longint;

      begin
         for i:=0 to 12 do
           if f.name[i]=#0 then
             begin
                l:=i;
                break;
             end;
         for i:=11 downto 0 do
           f.name[i+1]:=f.name[i];
         f.name[0]:=chr(l);
      end;

    procedure findfirst(const path : pathstr;attr : word;var f : searchRec);

      procedure _findfirst(path : pchar;attr : word;var f : searchrec);

        begin
           asm
              movl 18(%ebp),%edx
              movb $0x1a,%ah
              int $0x21
              movl 12(%esp),%edx
              movzwl 16(%esp),%ecx
              movb $0x4e,%ah
              int $0x21
              jnc LFF
              movw %ax,U_DOS_DOSERROR
           LFF:
           end;
        end;

      var
         path0 : array[0..80] of char;

      begin
         { no error }
         doserror:=0;
         strpcopy(path0,path);
         _findfirst(path0,attr,f);
         dossearchrec2searchrec(f);
      end;

    procedure findnext(var f : searchRec);

      procedure _findnext(var f : searchrec);

        begin
           asm
              movl 12(%ebp),%edx
              movb $0x1a,%ah
              int $0x21
              movb $0x4f,%ah
              int $0x21
              jnc LFN
              movw %ax,U_DOS_DOSERROR
           LFN:
           end;
        end;

      begin
         { no error }
         doserror:=0;
         searchrec2dossearchrec(f);
         _findnext(f);
         dossearchrec2searchrec(f);
      end;

    procedure swapvectors;

      begin
         { tut nichts, DOS-Extender übernimmt das Nötige }
         { normalerweise selber                          }
         { nur aus Kompatibilitätsgründen implementiert  }
      end;

    type
       ppchar = ^pchar;

    function envs : ppchar;

      begin
         asm
            movl _environ,%eax
            leave
            ret
         end ['EAX'];
      end;

    function envcount : longint;

      var
         hp : ppchar;

      begin
         hp:=envs;
         envcount:=0;
         while assigned(hp^) do
           begin
              { not the best solution, but quite understandable }
              inc(envcount);
              hp:=hp+4;
           end;
      end;

    function envstr(index : longint) : string;

      var
         hp : ppchar;

      begin
         if (index<=0) or (index>envcount) then
           begin
              envstr:='';
              exit;
           end;
         hp:=envs+4*(index-1);
         envstr:=strpas(hp^);
      end;

    function getenv(const envvar : string) : string;

      var
         hs,_envvar : string;
         eqpos,i : longint;

      begin
         _envvar:=upcase(envvar);
         getenv:='';
         for i:=1 to envcount do
           begin
              hs:=envstr(i);
              eqpos:=pos('=',hs);
              if copy(hs,1,eqpos-1)=_envvar then
                begin
                   getenv:=copy(hs,eqpos+1,length(hs)-eqpos);
                   exit;
                end;
           end;
      end;

    procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;
      var ext : extstr);

      var
         p1 : byte;

      begin
         { try to find out a extension }
         p1:=pos('.',path);
         if p1>0 then
           begin
              ext:=copy(path,p1,4);
              delete(path,p1,length(path)-p1+1);
           end
         else
           ext:='';
         { get drive name }
         p1:=pos(':',path);
         if p1>0 then
           begin
              dir:=path[1]+':';
              delete(path,1,p1);
           end
         else
           dir:='';
         { split the path and the name, there are no more path informtions }
         { if path contains no backslashes                                 }
         while true do
           begin
              p1:=pos('\',path);
              if p1=0 then
                break;
              dir:=dir+copy(path,1,p1);
              delete(path,1,p1);
           end;
         name:=path;
      end;

    function fexpand(const path : pathstr) : pathstr;

      function get_current_drive : byte;

        var
           r : registers;

        begin
           r.ah:=$19;
           msdos(r);
           get_current_drive:=r.al;
        end;

       var
          s,pa : string[79];

       begin
          { There are differences between FPKPascal and Turbo Pascal
            e.g. for the string 'D:\DEMO\..\HELLO' which isn't handled }
          getdir(0,s);
          pa:=upcase(path);
          if (ord(pa[0])>1) and (((pa[1]>='A') and (pa[1]<='Z')) and (pa[2]=':')) then
            begin
               if (ord(pa[0])>2) and (pa[3]<>'\') then
                 if pa[1]=s[1] then
                   pa:=s+'\'+copy (pa,3,length(pa))
                 else
                   pa:=pa[1]+':\'+copy (pa,3,length(pa))
            end
          else
            if pa[1]='\' then
              pa:=s[1]+':'+pa
            else if s[0]=#3 then
              pa:=s+pa
            else
              pa:=s+'\'+pa;
          fexpand:=pa;
       end;

     procedure packtime(var d : datetime;var time : longint);

       var
          zs : longint;

       begin
          time:=-1980;
          time:=time+d.year and 127;
          time:=time shl 4;
          time:=time+d.month;
          time:=time shl 5;
          time:=time+d.day;
          time:=time shl 16;
          zs:=d.hour;
          zs:=zs shl 6;
          zs:=zs+d.min;
          zs:=zs shl 5;
          zs:=zs+d.sec div 2;
          time:=time+(zs and $ffff);
       end;

     procedure unpacktime (time: longint; var d: datetime);

       begin
          d.sec:=(time and 31) * 2;
          time:=time shr 5;
          d.min:=time and 63;
          time:=time shr 6;
          d.hour:=time and 31;
          time:=time shr 5;
          d.day:=time and 31;
          time:=time shr 5;
          d.month:=time and 15;
          time:=time shr 4;
          d.year:=time + 1980;
       end;

    procedure getfattr(var f;var attr : word);

      var
         { to avoid problems }
         n : array[0..255] of char;
         r : registers;

      begin
         strpcopy(n,filerec(f).name);
         r.ax:=$4300;
         r.edx:=longint(@n);
         msdos(r);
         attr:=r.cx;
      end;

    procedure setfattr(var f;attr : word);

      var
         { to avoid problems }
         n : array[0..255] of char;
         r : registers;

      begin
         strpcopy(n,filerec(f).name);
         r.ax:=$4301;
         r.edx:=longint(@n);
         r.cx:=attr;
         msdos(r);
      end;

end.